;; P System for Aesthetics
;;
;; Copyright 2011:
;; James McDermott <jamesmichaelmcdermott@gmail.com>
;; Mark Wagy <mark.wagy@gmail.com>
;;
;; This file is part of p-gen, a p-systems and evolutionary system
;; written in Clojure.
;;
;; p-gen is licensed under GNU GPL v3.
;;
;; http://code.google.com/p/p-gen/

(ns psystem.psys)
(require 'clojure.string)
(require 'clojure.contrib.prxml)
(require 'clojure.xml)

(def DEBUG 1)

;; move-to-membrane-id = defines where this object moves
;; if it is 'seen' in the RHS of a rule application
(defrecord obj [value move-mem-id])

;; pred-fn = condition on which rule is invoked
;; let's make it a function that operates on a vector
;; and returns either true or false, shall we?
(defrecord rule [lhs rhs pred-fn move-mem-id])


(defn make-rule
  "Make a rule."
  ;; predicate function always returns true by default
  ([lhs rhs] (rule. lhs rhs #(= 1 1) nil)) 
  ([lhs rhs predfn] (rule. lhs rhs predfn nil))
  ([lhs rhs predfn move-mem-id] (rule. lhs rhs predfn move-mem-id)))


;; this is a hack for lack of strongly-typed constructors...
(defn make-rule-withmove
  "Make a rule with a 'to-membrane-id' movement indicator and default predicate fn."
  ([lhs rhs to-mem-id] (rule. lhs rhs #(= 1 1) to-mem-id)))


(defn obj-tostring
  "Object as string."
  [obj]
  (str "[" (clojure.string/join "," (:value obj)) (if (and (:move-mem-id obj) (= DEBUG 1)) (str "](" (:move-mem-id obj) ")") "]")))


;; move object into membrane with id of mem-id
(defn object-in
  [obj mem-id])


;; indent x num-indents
(defn indent
  [x num-indents]
  (let [val (if (string? x) x (str x))]
    (reduce str (conj (apply vector (repeat num-indents " ")) x))))


(defn rule-tostring
  "Rule as string."
  ([rule] (rule-tostring rule 0))
  ([rule num-indents]
     (indent (format
	      "%s -> %s %s"
	      (clojure.string/join
	       (map obj-tostring (:lhs rule)))
	      (clojure.string/join
	       (map obj-tostring (:rhs rule)))
	      (if (:move-mem-id rule)
		(str "{to " (:move-mem-id rule) "}")
		""))
	     num-indents)))


(defn make-obj
  "Make an object."
  ([value move-mem-id] (obj. value move-mem-id))
  ([value] (obj. value nil)))


(defn objects-equal?
  "Tests whether two objects are equal."
  [o1 o2]
  (= (:value o1 o2)))


(defn replace-multiset
  "Compare a sequence (matcher) to another (replacee) and replace it with (replacer)."
  [matcher replacee replacer]
  (let [tmp (if (vector? replacee) replacee (vector replacee))]
    (if (= matcher tmp)
      replacer
       tmp)))


(defn tag-object-moves
  "Return new object with appropriately tagged 'move' membrane ids according to this rule."
  [rul obj]
  (if (:move-mem-id rul)
    (make-obj (:value obj) (:move-mem-id rul))
    obj))


(defn rewrite
  "Apply rewrite rule to object (and tag for membrane movement)."
  [rul obj]
  (replace-multiset (:lhs rul) (tag-object-moves rul obj) (:rhs rul)))


(defn rewrite-objz
  "Apply rewrite rule to all objects in vector."
  [rul objz]
  (reduce into (map rewrite (repeat (count objz) rul) objz)))


(defn apply-rule-to-objects
  "Apply a rule to a vector of objects."
  [r oz]
  (let [rule-lhs-len (count (:lhs r))
	rule-vals (map :value (:lhs r))]
    (loop [lft-oz oz
	   rtn-oz []]
      (let [lft-oz-vals (map :value lft-oz)]
	(cond
	 (empty? lft-oz)
	  rtn-oz ;; no objects left to check
	 (= (take rule-lhs-len lft-oz-vals) rule-vals)
	  (recur (drop rule-lhs-len lft-oz) (into rtn-oz (map (fn [x] (tag-object-moves r x)) (:rhs r))))
	  :else
	   (recur (next lft-oz) (conj rtn-oz (first lft-oz)))))))) ;; keep going
	 

(defn apply-rules-to-objects
  "Apply a vector of rules to a vector of objects."
  [rz oz]
  (if (empty? rz)
    oz
    (recur (rest rz) (apply-rule-to-objects (first rz) oz))))


(defrecord membrane [id rulz objz memz])


(defn membrane-tostring
  "Membrane as string."
  ([mem] (membrane-tostring mem 0))
  ([mem num-indents]
     (str
      "\n"
      (indent (str "{" (str (:id mem))) num-indents)
       "\n"
      (indent (clojure.string/join "," (map obj-tostring (:objz mem)))
	      (inc num-indents))
      "\n"
      (clojure.string/join "\n" (map rule-tostring (:rulz mem) (repeat (count (:rulz mem)) (inc num-indents))))
      ;; print sub-membranes
      (clojure.string/join "\n" (map membrane-tostring (:memz mem) (repeat (count (:memz mem)) (inc num-indents))))
      "\n"
      (indent "}" num-indents)
      "\n")))


(defn objz-from-rule
  "Get a vector of objects present in a rule."
  [rul]
  (let [lhs (:lhs rul)
	rhs (:rhs rul)] (apply vector (into lhs rhs))))


(defn objz-from-rulz
  "Get a vector of objects present in a vector of rules."
  [rulz]
  (reduce into (map objz-from-rule rulz)))


(defn make-membrane
  "Make a memobrane"
  ([rulz] (make-membrane 0 rulz))
  ([id rulz] (let [objz (objz-from-rulz rulz)]
	       (make-membrane id rulz objz)))
  ([id rulz objz] (make-membrane id rulz objz []))
  ([id rulz objz memz]
     (membrane. id rulz objz memz)))


(defn copy-membrane-shallow
  "Copy membrane (shallow - does not copy recursive membranes!) into a new one with new id."
  [mem new-id]
  (make-membrane new-id (:rulz mem) (:objz mem) []))


(defn membrane-remove-object
  "Remove an object from this membrane."
  [mem obj]
  (make-membrane (:id mem) (:rulz mem) (filter #(not= (:value obj) (:value %)) (:objz mem)) (:memz mem)))


(defn remove-object-from-membrane-byid
  "Get membrane tree with object removed from a particular membrane
   identified by its membrane id."
  [root-membrane obj mem-id]
  (let [curid   (:id root-membrane)
	currulz (:rulz root-membrane)
	curobjz (:objz root-membrane)
	curmemz (:memz root-membrane)]
    (if (= curid mem-id)
      (membrane-remove-object root-membrane obj)
      (make-membrane
       curid
       currulz
       curobjz
       (into [] (map (fn [m] (remove-object-from-membrane-byid m obj mem-id)) curmemz))))))


(defn move-object-to-normal-object
  "Change a move object into a non-move-object."
  [o]
  (make-obj (:value o)))


(defn move-objects-to-normal-objects
  "Change a vector of move objects into normal objects."
  [oz]
  (into [] (map move-object-to-normal-object oz)))


(defn clean-move-objects-in-membrane
  "Reset move objects to normal objects in membrane (recursively)."
  [m]
  (let [curid (:id m)
	currz (:rulz m)
	curoz (:objz m)
	curmz (:memz m)]
    (make-membrane 
     curid
     currz
     (move-objects-to-normal-objects curoz)
     (into [] (map (fn [x] (clean-move-objects-in-membrane x)) curmz)))))


(defn clean-move-objects-in-membranes
  "Clean out move operations that reside in the objects of membranes recursively."
  [mz]
  (into [] (map clean-move-objects-in-membrane mz)))


(defn remove-move-objects-from-membrane
  "Get membrane tree with 'move' object removed."
  [m]
  (let [curid   (:id m)
	currulz (:rulz m)
	curobjz (filter #(nil? (:move-mem-id %)) (:objz m))
	curmemz (:memz m)]
    (make-membrane
     curid
     currulz
     curobjz
     (into [] (map (fn [x] (remove-move-objects-from-membrane x)) curmemz)))))


(defn remove-move-objects-from-membranes
  "Apply remove-move-objects-from-membrane to multiple membranes."
  [mz]
  (map remove-move-objects-from-membrane mz))


(defn membrane-add-object
  "Add an object to this membrane."
  [mem obj]
  (make-membrane (:id mem) (:rulz mem) (conj (:objz mem) obj) (:memz mem)))


(defn add-object-to-membrane-byid
  "Get membrane tree with object added to a particular membrane
   identified by its membrane id."
  [root-membrane obj mem-id]
  (let [curid   (:id root-membrane)
	currulz (:rulz root-membrane)
	curobjz (:objz root-membrane)
	curmemz (:memz root-membrane)]
    (if (= curid mem-id)
      (membrane-add-object root-membrane obj)
      (make-membrane
       curid
       currulz
       curobjz
       (into [] (map (fn [m] (add-object-to-membrane-byid m obj mem-id)) curmemz))))))


(defn add-object-to-membranes-byid
  "Same as add-object-to-membrane-byid, but applied to multiple root membranes."
  [mz o mem-id]
  (map #(add-object-to-membrane-byid % o mem-id) mz))


(defn get-child-membranes
  [mz]
  "Get a vector of child membranes of the input membranes."
  (reduce into (map :memz mz)))


(defn get-membrane-by-id
  "Search recursively for a membrane by membrane id and return it."
  [membranes id]
  (loop [mz membranes]
    (let [cur (first mz)
	  curid (:id cur)
	  kidz (if (empty? (:memz cur)) [] (:memz cur))]
      (if
       (= curid id) cur
       (let [next-mz (into kidz (rest mz))]
	 (if (empty? next-mz)
	   nil
	   (recur next-mz)))))))


(defn get-objects-by-membrane-id
  "Get vector of objects within a particular membrane in a hierarchy given the target membrane id."
  [mz id]
  (let [m (get-membrane-by-id mz id)]
    (:objz m)))


(defn add-move-object-to-membrane
  "If this membrane is the correct membrane to move to, add this object."
  [m o]
  (let [curid (:id m)
	currz (:rulz m)
	curoz (:objz m)
	curmz (:memz m)]
    (if (= curid (:move-mem-id o))
      (membrane-add-object m o)
      (make-membrane
       curid
       currz
       curoz
       (into [] (map (fn [mem] (add-move-object-to-membrane mem o)) curmz))))))


(defn add-move-object-to-membranes
  "Use move object's move membrane id to move to the appropriate membranes."
  [mz o]
  (into [] (map #(add-move-object-to-membrane % o) mz)))


(defn add-move-objects-to-membranes
  "Recursively add vector of move objects to vector of membranes."
  [mz oz]
  (if (empty? oz)
    mz
    (recur (add-move-object-to-membranes mz (first oz)) (rest oz))))


(defn enumerate-membrane
  "Get new membrane that has been 'enumerated' (including sub-membranes)."
  [mem]
  (let [oz (apply-rules-to-objects (:rulz mem) (:objz mem))
	mz (map enumerate-membrane (:memz mem))]
    (make-membrane (:id mem) (:rulz mem) oz mz)))


(defn accumulate-objects-recursively
  "Recursively accumulate all objects present in a membrane."
  [m]
  (let [curoz (:objz m)
	curmz (:memz m)]
    (if (empty? curmz)
      curoz
      (reduce into curoz (map accumulate-objects-recursively curmz)))))


(defn accumulate-membranes-objects
  "Consolidate objects from multiple membranes into one vector of objects."
  [mz]
  (reduce into (map :objz mz)))


(defn get-objectval-move-entry
  "Get a key/value pair of an object value to its membrane move id."
  [o]
  {:val (:value o), :move-mem-id (:move-mem-id o)})


(defn accumulate-move-objects
  "Recursively accumulate all move actions present in objects in a membrane."
  [m]
  (let [oz (accumulate-objects-recursively m)]
    (filter #(not (nil? (:move-mem-id %))) oz)))


(defrecord psystem [membranez output-membrane-ids])


(defn make-psystem
  "Make a psystem."
  ([memz] (psystem. memz []))
  ([memz out-mem-ids] (psystem. memz out-mem-ids)))


(defn psystem-tostring
  "P-system as string."
  [psys]
  (let [memz (:membranez psys)
	out-mem-ids (:output-membrane-ids psys)]
    (str
     "\n{p"
     (when (not (empty? out-mem-ids))
       (str " | out membrane ids: " (clojure.string/join "," out-mem-ids)))
     (reduce str (map membrane-tostring memz (repeat (count memz))))
     "\n}\n")))


(defn concat-obj-vals
  "Concatenate object values."
  [oz]
  (reduce into [] (map :value oz)))


(defn concat-objvecs-to-val-vec
  "Concatenate vectors of objects to a single vector of object values."
  [oz-vecs]
  (reduce into [] (map concat-obj-vals oz-vecs)))


(defn get-psystem-output-membrane-ids
  [p]
  (:output-membrane-ids p))


(defn get-psystem-obects-vector-by-membrane-ids
  [p ids]
  (apply vector (map #(get-objects-by-membrane-id (:membranez p) %) ids)))


(defn get-output-vals
  "Get output of supercell/p-system according to the defined output ids. Collapsed according to input function (simple concatenation by default)."
   [p & fn-collapse]
   (let [out-ids (get-psystem-output-membrane-ids p)
	 clps-fn (if (nil? fn-collapse) concat-objvecs-to-val-vec)
	 out-oz-vec (get-psystem-obects-vector-by-membrane-ids p out-ids)]
     (clps-fn out-oz-vec)))


;; TODO this requires a fix, since (:membranez p) will now return just
;; the root membrane. See make-membrane-getting-id, below. The fix
;; will be to recurse into the tree of membranes, rather than mapping
;; over a list of them as formerly. However I'm leaving this for now
;; since I wonder if the change will interact with the changes
;; required to allow objects to be passed into/out of membranes. BUT
;; maybe I'm wrong and it already does recurse in this way? Not sure.
(defn enumerate-psystem
  "Enumerate a p-system."
  [p num-iters]
  (let [mz (:membranez p)
	mz-enum (into [] (map enumerate-membrane mz))
	;; here we want to remove 'move ids' from objects so they don't get moved again
	move-oz (reduce into [] (map accumulate-move-objects mz-enum)) 
	mz-aftermoves (clean-move-objects-in-membranes (add-move-objects-to-membranes mz-enum move-oz))]
    (if (<= num-iters 0)
      p
      (recur (make-psystem mz-aftermoves (:output-membrane-ids p)) (dec num-iters)))))


;;;;; REPL-based p-system construction ;;;;;
;; TODO: do we really want to have to build p systems from the REPL? seems painful.

(defn prompt-read
  "Prompt for REPL entry of value."
  [prompt]
  (print (format "%s: " prompt))
  (flush)
  (read-line))


(defn prompt-read-int
  "Prompt for REPL entry of integer."
  [prompt]
  (. Integer valueOf (prompt-read prompt)))


(defn y-or-n-prompt
  "Prompt from REPL for y/n value and convert to true/false."
  [prompt]
  (= "y" (prompt-read prompt)))


 (defn build-obj-repl
   "Build object from the REPL."
   []
   (let [num-components (prompt-read-int "number of object components")]
     (loop [curr-obj []
 	   num num-components]
       (if (> num 0)
 	(recur (conj curr-obj (symbol (prompt-read "component"))) (dec num))
 	(make-obj curr-obj)))))


;; TODO: not done
(defn build-rule-repl
  "Build rule from the REPL."
  []
  (let [num-objz-lhs (prompt-read-int "Number of objects on LHS")
	num-objz-rhs (prompt-read-int "Number of objects on RHS")]))



;; TODO: not done
(defn build-membrane-repl
  "Build membrane from the REPL."
  [])


;; TODO: not done
(defn build-psystem-repl
  "Build a p-system from the REPL."
  [])


;;;;;;;; XML read/write


;; need this because XML will concat elements as if they are strings
;; and any distinction between them will be lost
(defn split-out-els
  "Split object elements into separate 'el' vectors for XML write."
  [v]
  (apply vector (map into (repeat (count v) ['el]) (map vector v))))


(defmacro prepend-to-vector [v val]
  "Utility macro to add a value to the beginning of a vector
   for the sake of writing to XML via prxml in clojure.contrib"
  `(apply vector (conj (apply list ~v) (symbol ~val))))


(defn obj-tovec
  "Object as a vector for XML write."
  [o]
  (prepend-to-vector (split-out-els (:value o)) "object"))


(defn obj-toxml
  "Object as XML."
  [obj]
  (with-out-str
    (clojure.contrib.prxml/prxml (obj-tovec obj))))


(defn objz-tovec
  "Objects as vector for XML write."
  [oz]
  (let [fx-objs (map obj-tovec oz)]
    (prepend-to-vector fx-objs "objects")))


(defn objz-toxml
  "Vector of Objects as XML."
  [objz]
  (with-out-str
    (clojure.contrib.prxml/prxml (objz-tovec objz))))


(defn rul-tovec
  "Rule as a vector for XML write."
  [r]
  (let [rhs (prepend-to-vector (vector (objz-tovec (:rhs r))) "rhs")
	lhs (prepend-to-vector (vector (objz-tovec (:lhs r))) "lhs")]
    (prepend-to-vector (conj (conj [] rhs) lhs) "rule")))


(defn rul-toxml
  "Rule as XML."
  [r]
  (with-out-str
    (clojure.contrib.prxml/prxml (rul-tovec r))))


(defn rulz-tovec
  "Rules as vector for XML write."
  [rz]
  (let [fx-ruls (map rul-tovec rz)]
    (prepend-to-vector fx-ruls "rules")))


(defn rulz-toxml
  "Rules as XML."
  [rz]
  (with-out-str
    (clojure.contrib.prxml/prxml (rulz-tovec rz))))


(defn membrane-tovec
  "Membrane to vector for XML write."
  [m]
  (let [oz (objz-tovec (:objz m))
	rz (rulz-tovec (:rulz m))
	i (prepend-to-vector (vector (:id m)) "id")]
    (prepend-to-vector [i oz rz] "mem")))


(defn membrane-toxml
  "Membrane as XML."
  [m]
  (with-out-str
    (clojure.contrib.prxml/prxml (membrane-tovec m))))


(defn membranez-tovec
  "Membranes to vector for XML write."
  [mz]
  (let [fx-mz (map membrane-tovec mz)]
    (prepend-to-vector fx-mz "membranes")))


(defn membranez-toxml
  "Membranes to XML."
  [mz]
  (with-out-str
    (clojure.contrib.prxml/prxml (membranez-tovec mz))))


(defn psystem-tovec
  "P System to vector for XML write."
  [p]
  (prepend-to-vector (vector (membranez-tovec (:membranez p))) "psystem"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Ok, so XML is probably not the way to go (credit to James for pointing this out)
;; Probably just better to write things out in Clojure code, since the gains from
;; writing in and out to XML are minimal from just being represented natively as Clojure
;; code. We'll leave this as a TODO item.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn psystem-toxml
  "P System to XML."
  [p]
  (with-out-str
    (clojure.contrib.prxml/prxml (psystem-tovec p))))


;; TODO: test then build up through others
(defn els-fromxml
  "Elements from XML."
  [xml]
  (apply vector
	 (map symbol
	      (map first
		   (for [x (xml-seq xml) :when (= :el (:tag x))]
		     (:content x))))))


;; TODO:
(defn object-fromxml
  "Object from XML."
  [xml]
  ;; build object from xml
    (els-fromxml xml))


;; TODO:
(defn rule-fromxml
  "Rule from XML."
  [xml]
  ;; build rule from xml
  )

;; TODO:
(defn membrane-fromxml
  "Membrane from XML."
  [xml]
;;  (let [id (first
;;	    (for [f (:content xml) :when (= :id (:tag f))] (:content f)))
;;	objects (first
;		 (for [f (:content m) :when (= :objects (:tag f))] (:content f)))
;;	rules (first
;;	       (for [f (:content m) :when (= :objects (:tag f))] (:content f)))]
    ;; apply object-fromxml on each object
    ;; apply rule-fromxml on each rule
  )


;; TODO: not done
(defn psystem-fromxml
  "P System from XML."
  [xml]
  (let [mz (:content (first (:content xml)))]
    (for [m mz :when (= :mem (:tag m))]
      (:tag m)
      ;; apply membrane-fromxml to define each membrane within psystem
      )))


(defn save-psystem
  "Save a p-system to file."
  [psys file-name]
  (spit file-name (pr-str psys)))


(defn load-psystem
  "Load a psystem from file."
  [file-name]
  (read-string (slurp file-name)))





;; ;; A method of constructing a p-system directly from a single
;; ;; CFG-generatable specification string. Unfortunately this method
;; ;; creates and leaks a global variable "global-id" to give unique ids
;; ;; to all the membranes. I'm not able to grok macros enough to do it
;; ;; differently.
;; (defn make-membrane-getting-id [rules init-state & children]
;;   (do
;; 	(def global-id (inc global-id))
;; 	(make-membrane global-id rules init-state children)))

;; (defn make-psystem-from-spec-string [spec]
;;   (do
;; 	(def global-id -1)
;; 	(eval (read-string spec))))

;; ;; Grammar generating a specification string for a p-system. It can be
;; ;; turned into a p-system by running (make-psystem-from-spec-string
;; ;; s), where s is the output of this grammar.
;; (def psys-grammar
;; 	 '(
;; 	   ;; psys specification string
;; 	   (<psys-spec> (<membrane>))
;; 	   ;; one membrane
;; 	   (<membrane> ("(make-membrane-getting-id [" <rules> "]" <init_state> <optional_membranes> ")"))
;; 	   ;; zero or more membranes
;; 	   (<optional_membranes> () (<membrane> <optional_membranes>))
;; 	   ;; one or more rules
;; 	   (<rules> (<rule> <rules>) (<rule>))
;; 	   ;; one rule
;; 	   (<rule> ("(make-rule " <lhs> <rhs> ")"))
;; 	   ;; lhs
;; 	   (<lhs> ("[" <objects> "]"))
;; 	   ;; rhs
;; 	   (<rhs> ("[" <objects> "]"))
;; 	   ;; one or more objects
;; 	   (<objects> (<object>) (<object> <objects>))
;; 	   ;; one object
;; 	   (<object> ("'a ") ("'b ") ("'c ") ("'d "))
;; 	   ;; initial state
;; 	   (<init_state> ("[" <objects> "]"))
;; 	   ))

;; ;; A typical output of psys-grammar  is like this:
;; (make-membrane-getting-id ;; root membrane
;;  [(make-rule ['a ] ['a ]) ;; first rule
;;   (make-rule ['a ] ['a 'b ]) ;; second rule
;;   (make-rule ['b ] ['a 'a ])] ;; third rule
;;  ['b ] ;; initial state
;;  (make-membrane-getting-id ;; child of root
;;   [(make-rule ['b 'b ] ['a 'a 'b 'b ])] ;; first rule
;;   ['a 'b 'a ]) ;; initial state
;;  ) ;; end of root membrane, no other children

